home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swags_z.zip / TEXTEDIT.SWG / 0004_GHOSTED.PAS.pas < prev    next >
Pascal/Delphi Source File  |  1993-05-28  |  10KB  |  398 lines
  1. TR>Can anyone (please, it's important) , post here an example of a source code
  2. TR>that will show a text file , and let me scroll it (Up , Down ) ?
  3. TR>Also I need an example of a simple editor.
  4.  
  5. Try this for an example. Turbo Pascal 6.0+ source.
  6. Compiles to a 7K text editor. Neat?
  7.  
  8. {$A-,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X+}
  9. {$M $C00,0,0}
  10. program ghostEd; {Ghost Editor v0.4 (C) 1993 Sean L. Palmer}
  11. const
  12.  version='0.4';
  13.  maxF=$3FFF;     {only handles small files!}
  14.  txtColor=$B;
  15.  vSeg:word=$B800;
  16. var
  17.  nLines:byte;
  18.  halfPage:byte;
  19.  txt:array[0..maxF]of char;
  20.  crs,endF,pgBase,lnBase:integer;
  21.  x,y:word;
  22.  update:boolean;
  23.  theFile:file;
  24.  ticks:word absolute $40:$6C;   {ticks happen 18.2 times/second}
  25.  
  26. procedure syncTick;var i:word;begin i:=ticks;repeat until i<>ticks;end;
  27.  
  28. function readKey:char;assembler;asm mov ah,$07; int $21; end;
  29.  
  30. function keyPressed:boolean;assembler;asm mov ah,$B; int $21; and al,$FE;
  31. end; 
  32.  
  33. procedure moveScrUp(s,d,n:word);assembler;asm
  34.  mov cx,n;
  35.  push ds;
  36.  mov ax,vSeg; mov es,ax; mov ds,ax;
  37.  mov si,s; shl si,1;
  38.  mov di,d; shl di,1;
  39.  cld; repz movsw; {attr too!}
  40.  pop ds; @X:
  41.  end;
  42.  
  43. procedure moveScrDn(s,d,n:word);assembler;asm
  44.  mov cx,n;
  45.  push ds;
  46.  mov ax,vSeg; mov es,ax; mov ds,ax;
  47.  mov si,s; add si,cx; shl si,1;
  48.  mov di,d; add di,cx; shl di,1;
  49.  std; repz movsw; {attr too!}
  50.  pop ds; @X:
  51.  end;
  52.  
  53. procedure moveScr(var s;d,n:word);assembler;asm
  54.  mov cx,n; jcxz @X;
  55.  push ds;
  56.  mov ax,vSeg; mov es,ax;
  57.  mov di,d; shl di,1;
  58.  lds si,s;
  59.  cld;
  60. @L: movsb; inc di; loop @L;
  61.  pop ds; @X:
  62.  end;
  63.  
  64. procedure fillScr(d,n:word;c:char);assembler;asm
  65.  mov cx,n; jcxz @X;
  66.  mov ax,vSeg; mov es,ax;
  67.  mov di,d; shl di,1;
  68.  mov al,c; cld;
  69. @L: stosb; inc di; loop @L;
  70. @X:
  71.  end;
  72.  
  73. procedure fillAttr(d,n:word;c:byte);assembler;asm
  74.  mov cx,n; jcxz @X;
  75.  mov ax,vSeg; mov es,ax;
  76.  mov di,d; shl di,1;
  77.  mov al,c; cld;
  78. @L: inc di; stosb; loop @L;
  79. @X:
  80.  end;
  81.  
  82. procedure cls;begin
  83.  fillAttr(80,pred(nLines)*80,txtColor);
  84.  fillScr(80,pred(nLines)*80,' ');
  85.  end;
  86.  
  87. procedure scrollUp;begin
  88.  moveScrUp(320,160,pred(nLines)*160);
  89.  fillScr(pred(nLines)*160,80,' ');
  90.  end;
  91. procedure scrollDn;begin
  92.  moveScrDn(160,320,pred(nLines)*320);
  93.  fillScr(160,80,' ');
  94.  end;
  95.  
  96. {put cursor after preceding CR or at 0}
  97. function scanCrUp(i:integer):integer;assembler;asm
  98.  mov di,i; mov cx,di; add di,offset txt
  99.  mov ax,ds; mov es,ax;
  100.  std; mov al,$D;
  101.  dec di;
  102.  repnz scasb;
  103.  jnz @S; inc di; @S:
  104.  inc di;
  105.  sub di,offset txt;
  106.  mov ax,di;
  107.  end;
  108.  
  109. {put cursor on next CR or endF}
  110. function scanCrDn(i:integer):integer;assembler;asm
  111.  mov di,i; mov cx,endF;
  112.  sub cx,di; inc cx; add di,offset txt;
  113.  mov ax,ds; mov es,ax;
  114.  cld; mov al,$D;
  115.  repnz scasb;
  116.  dec di;
  117.  sub di,offset txt;
  118.  mov ax,di;
  119.  end;
  120.  
  121. procedure findxy;begin
  122.  lnBase:=scanCrUp(crs);x:=crs-lnBase;
  123.  y:=1;pgBase:=lnBase;
  124.  while(pgBase>0)and(y<halfPage) do begin
  125.   pgBase:=scanCrUp(pred(pgBase)); inc(y);
  126.   end;
  127.  end;
  128.  
  129. procedure display;var i,j,k,oldY:integer;begin
  130.  findXY;
  131.  if update then begin
  132.   update:=false;
  133.   j:=pgBase;i:=1;
  134.   while (j<=endf) and (i<pred(nLines)) do begin
  135.    k:=scanCrDn(j);
  136.    moveScr(txt[j],i*80,k-j);
  137.    fillScr(i*80+k-j,80-k+j,' ');
  138.    fillAttr(i*80,80,txtColor);
  139.    j:=succ(k); inc(i);
  140.    end;
  141.   if i<pred(nLines) then begin
  142.    fillScr(i*80,80*pred(nLines-i),'X');
  143.    fillAttr(i*80,80*pred(nLines-i),1);
  144.    end;
  145.   end
  146.  else begin
  147. >>> Continued to next message
  148.  
  149.  * OLX 2.2 * "Could you continue your petty bickering? I find it most 
  150.  
  151. --- Maximus 2.01wb
  152.  * Origin: >>> Sun Mountain BBS <<< (303)-665-6922 (1:104/123)
  153. 
  154. >>> Continued from previous message
  155.   i:=scanCrDn(lnBase)-lnBase;
  156.   moveScr(txt[lnBase],y*80,i);
  157.   fillScr(y*80+i,80-i,' ');
  158.   end;
  159.  end;
  160.  
  161. const menuStr:string='Ghost Editor v'+version+'-(C) Sean Palmer 1993';
  162. procedure title;begin
  163.  fillAttr(0,80,$70);fillScr(0,80,' ');
  164.  MoveScr(MenuStr[1],1,length(MenuStr));
  165.  end;
  166.  
  167. procedure error(s:string);begin
  168.  fillattr(0,80,$CE);fillScr(0,80,' ');
  169.  moveScr(s[1],1,length(s));
  170.  write(^G);readkey;
  171.  title;
  172.  end;
  173.  
  174. procedure tooBigErr;begin error('File too big');end;
  175.  
  176. procedure insChar(c:char);forward;
  177. procedure delChar;forward;
  178. procedure backChar;forward;
  179.  
  180. procedure trimLine;var i,t,b:integer;begin
  181.  i:=crs;
  182.  b:=scanCrDn(crs); t:=scanCrUp(crs);
  183.  crs:=b;
  184.  while txt[crs]=' ' do begin
  185.   delchar;
  186.   if i>crs then dec(i);
  187.   if crs>0 then dec(crs);
  188.   end;
  189.  crs:=i;
  190.  end;
  191.  
  192. procedure checkWrap(c:integer);var i,t,b:integer;begin
  193.  b:=scanCrDn(c); t:=scanCrUp(c);
  194.  i:=b;
  195.  if i-t>=79 then begin
  196.   i:=t+79;
  197.   repeat dec(i); until (txt[i]=' ')or(i=t);
  198.   if i=t then backChar   {just disallow lines that long with no spaces}
  199.   else begin
  200.    txt[i]:=^M;  {change sp into cr, to wrap}
  201.    update:=true;
  202.    if (b<endF)and(txt[b]=^M)and(txt[succ(b)]<>^M) then begin
  203.     txt[b]:=' '; {change cr into sp, to append wrapped part to next line}
  204.     checkWrap(b); {recursively check next line since it got stuff added}
  205.     end;
  206.    end;
  207.   end;
  208.  end;
  209.  
  210. procedure changeLines;begin
  211.  trimLine; update:=true;  {signal to display to redraw}
  212.  end;
  213.  
  214. procedure insChar(c:char);begin
  215.  if endf=maxF then begin tooBigErr;exit;end;
  216.  move(txt[crs],txt[succ(crs)],endf-crs);
  217.  txt[crs]:=c;inc(crs);inc(endf);
  218.  if c=^M then changeLines;
  219.  checkWrap(crs);
  220.  end;
  221. procedure delChar;begin
  222.  if crs=endf then exit;
  223.  if txt[crs]=^M then changeLines;
  224.  move(txt[succ(crs)],txt[crs],endf-crs);
  225.  dec(endf);
  226.  checkWrap(crs);
  227.  end;
  228.  
  229. procedure addLF;var i:integer;begin
  230.  for crs:=endF downto 1 do if txt[pred(crs)]=^M then begin
  231.   insChar(^J); dec(crs);
  232.   end;
  233.  end;
  234.  
  235. procedure stripLF;var i:integer;begin
  236.  for crs:=endF downto 0 do if txt[crs]=^J then delChar;
  237.  end;
  238.  
  239. procedure writeErr;begin error('Write Error');end;
  240.  
  241. procedure saveFile;begin
  242.  addLF;
  243.  rewrite(theFile,1);
  244.  if ioresult<>0 then writeErr
  245.  else begin
  246.   blockwrite(theFile,txt,endf);
  247.   if ioresult<>0 then writeErr;
  248.   close(theFile);
  249.   end;
  250.  end;
  251.  
  252. procedure newFile;begin crs:=0;endF:=0;update:=true;end;
  253.  
  254. procedure readErr;begin error('Read Error');end;
  255.  
  256. procedure loadFile;var i,n:integer;begin
  257.  reset(theFile,1);
  258.  if ioresult<>0 then newFile
  259.  else begin
  260.   n:=filesize(theFile);if n>maxF then begin tooBigErr;n:=maxF;end;
  261.   blockread(theFile,txt,n,i);if i<n then readErr;
  262.   close(theFile);
  263.   crs:=0;endf:=i;update:=true;
  264.   stripLF;
  265.   end;
  266.  end;
  267.  
  268. procedure signOff;var f:file;i,n:integer;begin
  269.  assign(f,'signoff.txt');
  270.  reset(f,1);
  271.  if ioresult<>0 then error('No SIGNOFF.TXT defined')  {no macro defined}
  272.  else begin
  273.   n:=filesize(f);
  274.   blockread(f,txt[endF],n,i);if i<n then readErr;
  275.   close(f);
  276.   inc(endf,i);update:=true;
  277.   i:=crs; stripLF; crs:=i; {stripLF messes with crs}
  278.   end;
  279.  end;
  280.  
  281. procedure goLf;begin
  282.  if crs>0 then dec(crs);
  283.  if txt[crs]=^M then changeLines;
  284.  end;
  285. procedure goRt;begin
  286.  if txt[crs]=^M then changeLines;
  287.  if crs<endf then inc(crs);
  288.  end;
  289. procedure goCtrlLf;var c:char;begin
  290.  repeat goLf;c:=txt[crs];until (c<=' ')or(crs=0);
  291.  end;
  292. procedure goCtrlRt;var c:char;begin
  293.  repeat goRt;c:=txt[crs];until (c<=' ')or(crs>=endF);
  294.  end;
  295. procedure goUp;var i:integer;begin
  296.  if lnBase>0 then begin
  297.   changeLines;
  298.   lnBase:=scanCrUp(pred(lnBase));crs:=lnBase;
  299.   i:=scanCrDn(crs)-crs;
  300. >>> Continued to next message
  301.  
  302.  * OLX 2.2 * "Could you continue your petty bickering? I find it most 
  303.  
  304. --- Maximus 2.01wb
  305.  * Origin: >>> Sun Mountain BBS <<< (303)-665-6922 (1:104/123)
  306.                                                                              
  307.  
  308.                            >>> Continued from previous message
  309.   if i>=x then inc(crs,x) else inc(crs,i);
  310.   end;
  311.  end;
  312. procedure goDn;var i:integer;begin
  313.  changeLines;
  314.  crs:=scanCrDn(crs);if crs>=endF then exit;
  315.  inc(crs);lnBase:=crs;
  316.  i:=scanCrDn(crs)-crs;
  317.  if i>=x then inc(crs,x) else inc(crs,i);
  318.  end;
  319. procedure goPgUp;var i:byte;begin for i:=halfPage downto 0 do goUp; end;
  320. procedure goPgDn;var i:byte;begin for i:=halfPage downto 0 do goDn; end;
  321. procedure goHome;begin crs:=scanCrUp(crs); end;
  322. procedure goEnd;begin crs:=scanCrDn(crs); end;
  323.  
  324. procedure backChar;begin
  325.  if (crs>0) then begin goLf; delChar; end;
  326.  end;
  327.  
  328. procedure deleteLine;var i:integer;begin
  329.  i:=scanCrDn(crs);crs:=scanCrUp(crs);
  330.  if i<endF then begin move(txt[succ(i)],txt[crs],endf-i); dec(endF);end;
  331.  dec(endf,i-crs); changeLines;
  332.  end;
  333.  
  334. procedure flipCursor;var j,k,l:word;begin
  335.  j:=succ((y*80+x)shl 1);
  336.  l:=mem[vSeg:j];   {save attr under cursor}
  337.  mem[vSeg:j]:=$7B; if not keypressed then syncTick;
  338.  mem[vSeg:j]:=l; if not keypressed then syncTick;
  339.  end;
  340.  
  341. procedure edit;var c:char;begin
  342.  repeat
  343.   display;
  344.   repeat flipcursor;until keypressed;
  345.   c:=readkey;
  346.   if c=#0 then case readkey of
  347.    #59:signOff;
  348.    #75:goLf;
  349.    #77:goRt;
  350.    #115:goCtrlLf;
  351.    #116:goCtrlRt;
  352.    #72:goUp;
  353.    #80:goDn;
  354.    #83:delChar;
  355.    #73:goPgUp;
  356.    #81:goPgDn;
  357.    #71:goHome;
  358.    #79:goEnd;
  359.    end
  360.   else case c of
  361.    ^[:saveFile;
  362.    ^H:backChar;
  363.    ^C:{abortFile};
  364.    ^Y:deleteLine;
  365.    else insChar(c);
  366.    end;
  367.   until (c=^[)or(c=^C);
  368.  end;
  369.  
  370. function getRows:byte;assembler;asm
  371.  mov ax,$1130; xor dx,dx; int $10;
  372.  or dx,dx; jnz @S; mov dx,24; @S: {cga/mda don't have this fn}
  373.  inc dx; mov al,dl;
  374.  end;
  375.  
  376. var oldMode:byte;
  377. begin
  378.  asm mov ah,$F; int $10; mov oldMode,al; end;  {save old Gr mode}
  379.  if oldMode=7 then vSeg:=$B000;  {check for Mono}
  380.  nLines:=getRows;
  381.  halfPage:=pred(nLines shr 1);
  382.  cls; title;
  383.  if paramCount=0 then error('Need filename as parameter')
  384.  else begin
  385.   asm mov bh,0; mov dl,0; mov dh,nLines; mov ah,2; int $10; end; {put cursor
  386. of   assign(theFile,paramStr(1));
  387.   loadFile;
  388.   edit;
  389.   end;
  390.  end.
  391.  
  392.  * OLX 2.2 * "Could you continue your petty bickering? I find it most 
  393.  
  394. --- Maximus 2.01wb
  395.  * Origin: >>> Sun Mountain BBS <<< (303)-665-6922 (1:104/123)
  396.                                                                              
  397.  
  398.